Visualization of Master Thesis

Meng Zhang

April 2016

# painting (1.1)
dtp <- fread(paste0(path,"0_doc/3paintings.txt"),skip=4)
dtp <- dtp[NoOfFaces==1 & MediaTime %in% c(33,433,967)]
cols_to_keep <- grep("AU", names(dtp), value = TRUE)
dtp <- dtp[, ..cols_to_keep]
dtp <- dtp[, lapply(.SD, function(x) ifelse(x < 0, 0, ifelse(x>2,2,x)))]
dtp <- data.table(t(dtp),keep.rownames = T)
dtp[,rn := gsub(pattern = " Evidence",replacement = "",x=rn)]

# Validation using CK data (2.1) 
dtck <- data.table(read_excel(paste0(path,"0_doc/ACC_CK.xlsx"), sheet = "Sheet2"))
dtck[,Acc.:= paste(round(Acc.,3)*100,"%")]
dtck[,'URL (source: iMotions)' := ""]

# AUs Data (3.1)
dta1 <- fread(paste0(path,"1_data/A1_freq&sum.csv"))

# ML Data (3.2)
dtml <- as.data.table(read_excel("C:/zm/MA/1_data/erg_arbeit.xlsx", sheet = "vp", range = "A2:E32"))
setnames(dtml,"Dataset","vp")
dtml[,vp:= as.character(1:30)]

0 Introduction

This page documents data visualization content involved in my master thesis (Zhang (2016)). Basically, highcharter and kableExtra packages in R language were employed. The presentation of this RMarkdown was facilitated using template in rmdformats package.

1 Background

1.1 FACS

The Facial Action Coding System (FACS, Ekman and Friesen (1978)) can be used to describe facial expressions systematically based on activity in atomic units of facial action, the action units (AUs).

Examples

American_Gothic
American_Gothic

AU Polar Plot

highchart() %>%
  hc_chart(type = "line", polar = TRUE) %>% 
  hc_xAxis(categories = dtp[,rn]) %>% 
  hc_yAxis(min=-2, max = 2) %>% 
  hc_add_series(
    name = "Woman",
    data = dtp[,V2],
    pointPlacement = "on",
    type = "line",
    color = "#b45c3f",
    showInLegend = TRUE
    )%>% 
  hc_add_series( 
    name = "Man",
    data = dtp[,V3],
    pointPlacement = "on",
    type = "line",
    color = "#a2b19b",
    showInLegend = TRUE
    )

1.2 Emotions and AUs

Emotional facial expressions can be assessed through the evaluation of AUs or the combination of different AUs. Although Ekman and Friesen (1978) suggested that specific combinations of AUs represent a prototypical expression of emotion, the emotion-related expressions are not part of the FACS (Kanade, Cohn, and Tian (2000)). The FACS itself is purely descriptive and does not include inferential labels.

dta <- data.table(
  Emotion = c("fear","sadness","surprise","surprise","anger","disgust","sadness",
              "fear","surprise","disgust","joy","anger","disgust","disgust",
              "joy","sadness","anger","disgust","sadness","anger","fear","fear"),
  AU = c("AU 1","AU 1","AU 1","AU 2","AU 4","AU 4","AU 4","AU 5",
         "AU 5","AU 6","AU 6","AU 7","AU 9","AU 10","AU 12","AU 15",
         "AU 17","AU 17","AU 17","AU 23","AU 25","AU 26")
  
)

hchart(data_to_sankey(dta), "sankey", name = "Emotions and AUs",
       nodes = list(list(id = 'fear'  , color = "#00008B"),
               list(id = 'sadness'  , color = "#778899"),
               list(id = 'surprise'  , color = "#FFA500"),
               list(id = 'anger'  , color = "#FF0000"),
               list(id = 'disgust'  , color = "#808000"),
                list(id = 'joy'  , color = "#FFD700")))%>%
  hc_title(text= "Sankey Diagram") %>%
  hc_subtitle(text= "Action Units and Emotions")  %>%
  hc_caption(text = "<b>based on Ekman and Friesen (1978).<b>")%>%
  hc_add_theme(hc_theme_smpl())

2 Method

2.1 Validation of software

The Attention Tool FACET Module (FACET, iMotions), which is a face and AU detection software based on the FACS. This software can track and quantify changes in AUs frame by frame and was validated in studies comparing with human coders (Krumhuber et al. (2021)) and comparing with facial Electromyography (EMG) recording (Kulke, Feyerabend, and Schacht (2020)). Before the application of the software, it was evaluated using the images from the extended Cohn-Kanade Facial Expression Database (CK+, Lucey et al. (2010)). Below are the validation results.

kbl(dtck, escape = F) %>%
  kable_paper(full_width = F, bootstrap_options = c("striped", "hover", "condensed", "responsive"))%>%
  column_spec(5, image = spec_image(
    c("https://imotions.com/wp-content/uploads/2022/10/AU1-FACS.gif", 
      "https://imotions.com/wp-content/uploads/2022/10/AU2-right-only.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU4-brow-lowerer.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU5.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU6-cheek-raiser.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU7-lid-tightener.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU9-with-410.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU10-with-25.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU12.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU14-dimpler.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU15.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU17.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU18-with-22A-and-25A.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU20-lip-stretcher.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU23-lip-tightener.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU24.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU25-lips-part.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU26-with-25.gif",
      "https://imotions.com/wp-content/uploads/2022/10/AU28-with-26.gif"), 150, 70))
AU Bedeutung Acc. N URL (source: iMotions)
1 Heben der inneren Augenbraue 89.7 % 175
2 Heben der äußeren Augenbraue 88.9 % 117
4 Senken der Brauen 94.3 % 194
5 Heben der Oberlider 95.1 % 102
6 Heben der Wangen 92.7 % 123
7 Spannen der Lider 93.4 % 121
9 Nase rümpfen 100 % 75
10 Heben der Oberlippen 90.5 % 21
12 Heben der Mundwinkel 95.4 % 131
14 Grübchen 67.6 % 37
15 Mundwinkel senken 89.4 % 94
17 Kinn anheben 86.6 % 202
18 Lippen spitzen 88.9 % 9
20 Lippen dehnen 92.4 % 79
23 Lippen spannen 63.3 % 60
24 Lippen zusammenpressen 65.5 % 58
25 Öffnen des Mundes 76.9 % 324
26 Unterkiefer fallen lassen 48 % 50
28 Lippen einsaugen 100 % 1

2.2 Experiment Design

the participants drove twelve driving simulator scenarios on a two-lane urban road. Frustration was induced by a combination of time pressure and obstacles (Frust). In three scenarios, the participants had almost free driving in moderate traffic (noFrust).

2.3 Supervised classification

Which classifier has the best accuracy in classifying frustration? According to the experimental design, an occurrence of frustration is expected in the Frust condition, especially during obstacles events. Conversely, a neutral state is expected in the noFrust condition. Therefore, each frame has an experimental label. To evaluate the classification, we selected the following four classifiers: Naive Bayes, Logistic Regression, Random Forest, Support Vector Machine.

2.4 Unsupervised classification

K-Means uses the principle of spatial proximity to assign the observed data. Here, a random selection of the initial cluster centers is made and then iteratively refined in the following process.

x<-c(.5,1,1,2,2,3,3.5,4,4,5,5)
y<-c(1,2,3,2,4,3,5,1,4,4,3)

first<-matrix(c(2,5,1,1,1,2),2,3)
cex1<-2
cex2<-3

initialize

plot(x,y,xlim=c(0,6),ylim=c(0,6),pch=15,main="Data and initial centers in 2D space", xlab="Feature 1",ylab="Feature 2",
     cex=cex1)
points(first,col=c("lightblue","tomato"),pch=12,cex=cex2)

clustering

plot(x,y,xlim=c(0,6),ylim=c(0,6),pch=15,main="Clustered data and initial centers in 2D space", xlab="Feature 1",ylab="Feature 2",
     cex=cex1)
points(first,col=c("lightblue","tomato"),pch=12,cex=cex2)
points(x[1:6],y[1:6],col="lightblue",pch=15,cex=cex1)
points(x[7:11],y[7:11],col="tomato",pch=15,cex=cex1)

center recalculate

second<-matrix(c(mean(x[1:6]),mean(x[7:11]),mean(y[1:6]),mean(y[7:11])),2,2)
plot(x,y,xlim=c(0,6),ylim=c(0,6),pch=15,main="Clustered data and initial/updated centers", xlab="Feature 1",ylab="Feature 2",cex=cex1)
points(first,col=c("lightblue","tomato"),pch=12,cex=cex1)
points(x[1:6],y[1:6],col="lightblue",pch=15,cex=cex1)
points(x[7:11],y[7:11],col="tomato",pch=15,cex=cex1)
points(mean(x[1:6]),mean(y[1:6]),col="lightblue",pch=12,cex=cex2)
points(mean(x[7:11]),mean(y[7:11]),col="tomato",pch=12,cex=cex2)

arrows(first[1,1],first[1,2],second[1,1],second[1,2],code=2,cex=.1,length=.1)
arrows(first[2,1],first[2,2],second[2,1],second[2,2],code=2,cex=.1,length=.1)

center update

#Zuordnung
plot(x,y,xlim=c(0,6),ylim=c(0,6),pch=15,main="Clustered data and updated centers in 2D space", xlab="Feature 1",ylab="Feature 2")
points(mean(x[1:6]),mean(y[1:6]),col="lightblue",pch=12,cex=cex2)
points(mean(x[7:11]),mean(y[7:11]),col="tomato",pch=12,cex=cex2)
points(x[1:5],y[1:5],col="lightblue",pch=15,cex=cex1)
points(x[6:11],y[6:11],col="tomato",pch=15,cex=cex1)

3 Resutls

3.1 Activated Action Units

temp <- dta1[,.(m = mean(freq050, na.rm=T), ste = sd(freq050, na.rm=T)/sqrt(length(freq050))), by = .(AU, cond)]
temp[,AU := as.factor(AU)]
temp[,cond := factor(cond, level=c("frust","nofrust"))]

hchart(temp, "column",
       hcaes(x = AU, y = m, group = cond),
       id=c("a","b")) %>%
  hc_add_series(temp, "errorbar",
                hcaes(x = AU, y = m, low = m - ste, high = m + ste, group = cond),
                linkedTo = c("a", "b"),
                showInLegend = FALSE) %>%
  hc_plotOptions(errorbar = list(color = "black", stemWidth = 1)) %>%
  hc_yAxis(title = list(text = "Frequency of Activation"),
           labels = list(format = "{value}")) %>%
  hc_xAxis(title = list(text = "Action Units")) %>%
  hc_add_theme(hc_theme_smpl())

3.2 Evaluation of Machine Learning Models

temp <-copy(dtml)
temp <- melt(temp,id=1)
temp[,value:=round(value,2)]
temp[,variable:=factor(variable, levels=c("svm","NB","Log","RF"), labels = c("Support Vector Machine","Naive Bayes","Logistic Regression","Random Forest"))]

temp %>%
  hchart('spline', hcaes(x = vp, y = value, group = variable)) %>% 
  hc_xAxis(
    title = list(text = "Participants"))%>% 
  hc_yAxis(
    title = list(text = "Error rate"),
    labels = list(format = "{value} %"))

3.3 Clustering results

3.3.1 Five main clusters

highchart() %>%
  hc_chart(type = "line", polar = TRUE) %>% 
  hc_xAxis(categories = c("AU1", "AU2", "AU4","AU5","AU6","AU7","AU9","AU10","AU12","AU14","AU15","AU17","AU18","AU20","AU23","AU24","AU25","AU28")) %>% 
  hc_yAxis(min=-2, max = 2) %>% 
  hc_add_series(
    name = "Cluster1",
    data = c(-0.00689229534301518, 0.0146658321776044, -0.170238341157532, 0.0108424768892282, 0.0373471212268161, -0.0124238410019452, -0.204127409956917, 0.0120074761554221, 0.252737600694113, 0.0127371720236976, -0.00431673360429348, -0.0636929611773298, -0.221988189483472, -0.000418904436190968, -0.0494849821250738, -0.0898612702937807, 0.0018636612087927, 0.0839875648129451),
    pointPlacement = "on",
    type = "line",
    showInLegend = TRUE
    )%>% 
  hc_add_series( 
    name = "Cluster2",
    data = c(-0.0682134131676777, -0.0157963355638499, -0.30329700926915, 0.0300181668956184, 0.725137714849505, 0.00686445554333491, 0.501447599183491, 0.584408306333753, 1.36293370870626, 0.150859234163142, -0.349015491229172, 0.146295405325107, -0.00775400038698349, -0.0702325045234101, -0.0982615468923018, -0.401903892299507, 0.0595436853079723, 0.0118363813924743),
    pointPlacement = "on",
    type = "line",
    showInLegend = TRUE
    )%>% 
  hc_add_series( 
    name = "Cluster3",
    data = c(-0.0337912212961824, -0.024861465507002, 0.457267069692393, 0.0533649518994984, 0.0346719822087755, 0.220136027679208, 0.447379818849196, 0.0379544123145118, 0.176373236979506, 0.03378366127002, -0.0213953131541545, 0.130191947340001, 0.030047598361894, 0.0404447173541551, 0.152115293936114, 0.172987064827607, 0.00298017172518508, 0.273568941630955),
    pointPlacement = "on",
    type = "line",
    showInLegend = TRUE
    )%>% 
  hc_add_series( 
    name = "Cluster4",
    data = c(-0.0711468968927835, -0.0431345159118597, -0.0988184272962289, -0.0577405841191519, 0.0388219418496092, -0.0604814318247762, 0.346014148049919, 0.0674346791556342, -0.110471983724489, -0.0123121846790221, -0.0533357815158493, 0.26035589623147, 0.808639895163279, -0.223728496617008, 0.100697023786435, 0.311604771472312, -0.00604144108856648, -0.2961903902631),
    pointPlacement = "on",
    type = "line",
    showInLegend = TRUE
    )%>% 
  hc_add_series( 
    name = "Cluster5",
    data = c(-0.0209001964299712, 0.00548049356173341, 0.086884129261727, 0.0450308778978378, -0.0961904866125388, 0.0108757383527421, 0.0265067961786311, 0.0248744789127821, -0.466370851531444, -0.125532497762317, 0.0518096889233274, -0.0120214429301946, 0.120566136315713, -0.0141841168333413, -0.0101437928498482, 0.0130753851846284, -0.00786793449993431, -0.110689917807391),
    pointPlacement = "on",
    type = "line",
    showInLegend = TRUE
    )%>% 
  hc_add_theme(hc_theme_smpl())

3.3.2 Distribution of clusters in Frust/noFrust

temp <- data.table(
  Cluster = paste0("Clsuter",1:5),
  noFrust = c(22.57, 10.07, 22.82, 10.87, 33.69),
  Frust = c(20.56, 10.34, 19.16, 27.29, 22.66)
)
temp <- melt(temp,id=1)
temp[,variable := factor(variable, level=c("Frust","noFrust"))]

# kbl(temp, escape = F,caption = "Distribution of clusters in Frust/noFrust (%)") %>%
#   kable_paper(full_width = T, bootstrap_options = c("striped", "hover", "condensed", "responsive")) 


hc <- hchart(temp, "packedbubble", hcaes(name = variable, value = value, group = Cluster))
hc %>% 
  hc_tooltip(
    useHTML = TRUE,
    pointFormat = "<b>{point.name}:</b> {point.value}"
  ) %>% 
  hc_plotOptions(
    packedbubble = list(
      maxSize = "70%",
      zMin = 0,
      layoutAlgorithm = list(
        gravitationalConstant =  0.05,
        splitSeries =  TRUE, 
        seriesInteraction = TRUE,
        dragBetweenSeries = TRUE,
        parentNodeLimit = TRUE
      ),
      dataLabels = list(
        enabled = TRUE,
        format = "{point.name}",
        style = list(
          color = "black",
          textOutline = "none",
          fontWeight = "normal"
        )
      )
    )
  )%>% 
  hc_add_theme(hc_theme_smpl())

References

Ekman, Paul, and Wallace V Friesen. 1978. “Facial Action Coding System.” Environmental Psychology & Nonverbal Behavior.
Kanade, Takeo, Jeffrey F Cohn, and Yingli Tian. 2000. “Comprehensive Database for Facial Expression Analysis.” In Proceedings Fourth IEEE International Conference on Automatic Face and Gesture Recognition (Cat. No. PR00580), 46–53. IEEE.
Krumhuber, Eva G, Dennis Küster, Shushi Namba, Datin Shah, and Manuel G Calvo. 2021. “Emotion Recognition from Posed and Spontaneous Dynamic Expressions: Human Observers Versus Machine Analysis.” Emotion 21 (2): 447.
Kulke, Louisa, Dennis Feyerabend, and Annekathrin Schacht. 2020. “A Comparison of the Affectiva iMotions Facial Expression Analysis Software with EMG for Identifying Facial Expressions of Emotion.” Frontiers in Psychology 11: 329.
Lucey, Patrick, Jeffrey F Cohn, Takeo Kanade, Jason Saragih, Zara Ambadar, and Iain Matthews. 2010. “The Extended Cohn-Kanade Dataset (Ck+): A Complete Dataset for Action Unit and Emotion-Specified Expression.” In 2010 Ieee Computer Society Conference on Computer Vision and Pattern Recognition-Workshops, 94–101. IEEE.
Zhang, Meng. 2016. “Die Nutzung von Maschinellem Lernen Zur Erkennung von Frustration Bei Autofahrern Anhand von Videoaufnahmen Des Gesichts.” PhD thesis, Technische Universität Berlin.